home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / httpapp.int < prev    next >
Encoding:
Text File  |  1997-01-30  |  13.0 KB  |  361 lines
  1. unit HTTPApp;
  2.  
  3. interface
  4.  
  5. uses SyncObjs, SysUtils, Classes, Forms, Masks;
  6.  
  7. const
  8.   DateFormat = 'ddd, dd mmm yyyy hh:mm:ss';
  9.  
  10.   MAX_STRINGS = 13;
  11.   MAX_INTEGERS = 1;
  12.   MAX_DATETIMES = 3;
  13.  
  14. type
  15.   TCharSet = set of Char;
  16.   TMethodType = (mtAny, mtGet, mtPost, mtHead);
  17.  
  18. { TWebRequest }
  19.  
  20.   TWebRequest = class(TObject)
  21.   protected
  22.     function GetStringVariable(Index: Integer): string; virtual; abstract;
  23.     function GetDateVariable(Index: Integer): TDateTime; virtual; abstract;
  24.     function GetIntegerVariable(Index: Integer): Integer; virtual; abstract;
  25.   public
  26.     constructor Create;
  27.     destructor Destroy; override;
  28.     // Read count bytes from client
  29.     function ReadClient(var Buffer; Count: Integer): Integer; virtual; abstract;
  30.     // Read count characters as a string from client
  31.     function ReadString(Count: Integer): string; virtual; abstract;
  32.     // Translate a relative URI to a local absolute path
  33.     function TranslateURI(const URI: string): string; virtual; abstract;
  34.     // Write count bytes back to client
  35.     function WriteClient(var Buffer; Count: Integer): Integer; virtual; abstract;
  36.     // Write string contents back to client
  37.     function WriteString(const AString: string): Boolean; virtual; abstract;
  38.     // Utility to extract fields from a given string buffer
  39.     procedure ExtractFields(Separators, WhiteSpace: TCharSet;
  40.       Content: PChar; Strings: TStrings);
  41.     // Fills the given string list with the content fields as the result
  42.     // of a POST method
  43.     procedure ExtractContentFields(Strings: TStrings);
  44.     // Fills the given string list with values from the cookie header field
  45.     procedure ExtractCookieFields(Strings: TStrings);
  46.     // Fills the given TStrings with the values from the Query data
  47.     // (ie: data following the "?" in the URL)
  48.     procedure ExtractQueryFields(Strings: TStrings);
  49.     // Read an arbitrary HTTP/Server Field not lists here
  50.     function GetFieldByName(const Name: string): string; virtual; abstract;
  51.     // The request method as an enumeration
  52.     property MethodType: TMethodType;
  53.     // Field lists
  54.     property ContentFields: TStrings;
  55.     property CookieFields: TStrings;
  56.     property QueryFields: TStrings;
  57.     // HTTP header Fields
  58.     property Method: string index 0;
  59.     property ProtocolVersion: string index 1;
  60.     property URL: string index 2;
  61.     property Query: string index 3;
  62.     property PathInfo: string index 4;
  63.     property PathTranslated: string index 5;
  64.     property Authorization: string index 28;
  65.     property CacheControl: string index 6;
  66.     property Cookie: string index 27;
  67.     property Date: TDateTime index 7;
  68.     property Accept: string index 8;
  69.     property From: string index 9;
  70.     property Host: string index 10;
  71.     property IfModifiedSince: TDateTime index 11;
  72.     property Referer: string index 12;
  73.     property UserAgent: string index 13;
  74.     property ContentEncoding: string index 14;
  75.     property ContentType: string index 15;
  76.     property ContentLength: Integer index 16;
  77.     property ContentVersion: string index 17;
  78.     property Content: string index 25;
  79.     property Connection: string index 26;
  80.     property DerivedFrom: string index 18;
  81.     property Expires: TDateTime index 19;
  82.     property Title: string index 20;
  83.     property RemoteAddr: string index 21;
  84.     property RemoteHost: string index 22;
  85.     property ScriptName: string index 23;
  86.     property ServerPort: Integer index 24;
  87.   end;
  88.  
  89. { TWebResponse }
  90.  
  91.   TWebResponse = class(TObject)
  92.   protected
  93.     FHTTPRequest: TWebRequest;
  94.     procedure AddCustomHeaders(var Headers: string);
  95.     function GetStringVariable(Index: Integer): string; virtual; abstract;
  96.     procedure SetStringVariable(Index: Integer; const Value: string); virtual; abstract;
  97.     function GetDateVariable(Index: Integer): TDateTime; virtual; abstract;
  98.     procedure SetDateVariable(Index: Integer; const Value: TDateTime); virtual; abstract;
  99.     function GetIntegerVariable(Index: Integer): Integer; virtual; abstract;
  100.     procedure SetIntegerVariable(Index: Integer; Value: Integer); virtual; abstract;
  101.     function GetContent: string; virtual; abstract;
  102.     procedure SetContent(const Value: string); virtual; abstract;
  103.     procedure SetContentStream(Value: TStream); virtual;
  104.     function GetStatusCode: Integer; virtual; abstract;
  105.     procedure SetStatusCode(Value: Integer); virtual; abstract;
  106.     function GetLogMessage: string; virtual; abstract;
  107.     procedure SetLogMessage(const Value: string); virtual; abstract;
  108.     function Sent: Boolean; virtual;
  109.   public
  110.     constructor Create(HTTPRequest: TWebRequest);
  111.     destructor Destroy; override;
  112.     function GetCustomHeader(const Name: string): String;
  113.     procedure SendResponse; virtual; abstract;
  114.     procedure SendRedirect(const URI: string); virtual; abstract;
  115.     procedure SendStream(AStream: TStream); virtual; abstract;
  116.     procedure SetCookieField(Values: TStrings; const Domain, Path: string;
  117.       Expires: TDateTime; Secure: Boolean);
  118.     procedure SetCustomHeader(const Name, Value: string);
  119.     property HTTPRequest: TWebRequest;
  120.     property Version: string index 0;
  121.     property ReasonString: string index 1;
  122.     property Server: string index 2;
  123.     property WWWAuthenticate: string index 3;
  124.     property Realm: string index 4;
  125.     property Allow: string index 5;
  126.     property Location: string index 6;
  127.     property ContentEncoding: string index 7;
  128.     property ContentType: string index 8;
  129.     property ContentVersion: string index 9;
  130.     property DerivedFrom: string index 10;
  131.     property Title: string index 11;
  132.     property SetCookie: string index 12;
  133.  
  134.     property StatusCode: Integer;
  135.     property ContentLength: Integer index 0;
  136.  
  137.     property Date: TDateTime index 0;
  138.     property Expires: TDateTime index 1;
  139.     property LastModified: TDateTime index 2;
  140.  
  141.     property Content: string;
  142.     property ContentStream: TStream;
  143.  
  144.     property LogMessage: string;
  145.  
  146.     property CustomHeaders: TStrings;
  147.   end;
  148.  
  149. { TWebDispatcherEditor }
  150.  
  151.   TCustomWebDispatcher = class;
  152.   TCustomContentProducer = class;
  153.  
  154. { THTMLTagAttributes }
  155.  
  156.   THTMLAlign = (haDefault, haLeft, haRight, haCenter);
  157.   THTMLVAlign = (haVDefault, haTop, haMiddle, haBottom, haBaseline);
  158.   THTMLBgColor = type string;
  159.  
  160.   THTMLTagAttributes = class(TPersistent)
  161.   protected
  162.     procedure Changed;
  163.   public
  164.     constructor Create(Producer: TCustomContentProducer);
  165.     property Producer: TCustomContentProducer;
  166.     property OnChange: TNotifyEvent;
  167.   published
  168.     property Custom: string;
  169.   end;
  170.  
  171.   THTMLTableAttributes = class(THTMLTagAttributes)
  172.   protected
  173.     procedure AssignTo(Dest: TPersistent); override;
  174.   public
  175.     constructor Create(Producer: TCustomContentProducer);
  176.   published
  177.     property Align: THTMLAlign default haDefault;
  178.     property BgColor: THTMLBgColor;
  179.     property Border: Integer default -1;
  180.     property CellSpacing: Integer default -1;
  181.     property CellPadding: Integer default -1;
  182.     property Width: Integer default 100;
  183.   end;
  184.  
  185.   THTMLTableElementAttributes = class(THTMLTagAttributes)
  186.   protected
  187.     procedure AssignTo(Dest: TPersistent); override;
  188.   published
  189.     property Align: THTMLAlign default haDefault;
  190.     property BgColor: THTMLBgColor;
  191.     property VAlign: THTMLVAlign default haVDefault;
  192.   end;
  193.  
  194.   THTMLTableHeaderAttributes = class(THTMLTableElementAttributes)
  195.   protected
  196.     procedure AssignTo(Dest: TPersistent); override;
  197.   published
  198.     property Caption: string;
  199.   end;  
  200.  
  201.   THTMLTableRowAttributes = class(THTMLTableElementAttributes);
  202.   THTMLTableCellAttributes = class(THTMLTableElementAttributes);
  203.  
  204. { TCustomContentProducer }
  205.  
  206.   TCustomContentProducer = class(TComponent)
  207.   protected
  208.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  209.   public
  210.     function Content: string; virtual;
  211.     function ContentFromStream(Stream: TStream): string; virtual;
  212.     function ContentFromString(const S: string): string; virtual;
  213.   published  
  214.     property Dispatcher: TCustomWebDispatcher;
  215.   end;
  216.  
  217. { TCustomHTTPPageProducer }
  218.  
  219.   TCustomPageProducer = class(TCustomContentProducer)
  220.   protected
  221.     function HandleTag(const TagString: string; TagParams: TStrings): string; virtual;
  222.     property HTMLDoc: TStrings;
  223.     property HTMLFile: TFileName;
  224.   public
  225.     constructor Create(AOwner: TComponent); override;
  226.     destructor Destroy; override;
  227.     function Content: string; override;
  228.     function ContentFromStream(Stream: TStream): string; override;
  229.     function ContentFromString(const S: string): string; override;
  230.   end;
  231.  
  232. { TPageProducer }
  233.  
  234.   TTag = (tgCustom, tgLink, tgImage, tgTable, tgImageMap, tgObject, tgEmbed);
  235.  
  236.   THTMLTagEvent = procedure (Sender: TObject; Tag: TTag; const TagString: string;
  237.     TagParams: TStrings; var ReplaceText: string) of object;
  238.  
  239.   TPageProducer = class(TCustomPageProducer)
  240.   protected
  241.     function HandleTag(const TagString: string; TagParams: TStrings): string; override;
  242.     procedure DoTagEvent(Tag: TTag; const TagString: string; TagParams: TStrings;
  243.       var ReplaceText: string); dynamic;
  244.   published
  245.     property HTMLDoc;
  246.     property HTMLFile;
  247.     property OnHTMLTag: THTMLTagEvent;
  248.   end;
  249.  
  250. { TWebActionItem }
  251.  
  252.   THTTPMethodEvent = procedure (Sender: TObject; Request: TWebRequest;
  253.     Response: TWebResponse; var Handled: Boolean) of object;
  254.  
  255.   TWebActionItem = class(TCollectionItem)
  256.   public
  257.     constructor Create(Collection: TCollection); override;
  258.     destructor Destroy; override;
  259.     procedure AssignTo(Dest: TPersistent); override;
  260.   published
  261.     property Default: Boolean default False;
  262.     property Enabled: Boolean default True;
  263.     property MethodType: TMethodType default mtAny;
  264.     property Name: string;
  265.     property PathInfo: string;
  266.     property OnAction: THTTPMethodEvent;
  267.   end;
  268.  
  269. { TWebActionItems }
  270.  
  271.   TWebActionItems = class(TCollection)
  272.   protected
  273.     function GetAttrCount: Integer; override;
  274.     function GetAttr(Index: Integer): string; override;
  275.     function GetItemAttr(Index, ItemIndex: Integer): string; override;
  276.     function GetOwner: TPersistent; override;
  277.     procedure SetItemName(Item: TCollectionItem); override;
  278.     procedure Update(Item: TCollectionItem); override;
  279.   public
  280.     constructor Create(WebDispatcher: TCustomWebDispatcher;
  281.       ItemClass: TCollectionItemClass);
  282.     function  Add: TWebActionItem;
  283.     property WebDispatcher: TCustomWebDispatcher;
  284.     property Items[Index: Integer]: TWebActionItem; default;
  285.   end;
  286.  
  287. { TCustomWebDispatcher }
  288.  
  289.   TCustomWebDispatcher = class(TDataModule)
  290.   protected
  291.     function DoAfterDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
  292.     function DoBeforeDispatch(Request: TWebRequest; Response: TWebResponse): Boolean;
  293.     function DispatchAction(Request: TWebRequest;
  294.       Response: TWebResponse): Boolean;
  295.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  296.     property BeforeDispatch: THTTPMethodEvent;
  297.     property AfterDispatch: THTTPMethodEvent;
  298.   public
  299.     constructor Create(AOwner: TComponent); override;
  300.     destructor Destroy; override;
  301.     function ActionByName(const AName: string): TWebActionItem;
  302.     property Actions: TWebActionItems;
  303.     property Action[Index: Integer]: TWebActionItem;
  304.     property Request: TWebRequest;
  305.     property Response: TWebResponse;
  306.   end;
  307.  
  308. { TWebDispatcher }
  309.  
  310.   TWebDispatcher = class(TCustomWebDispatcher)
  311.   published
  312.     property Actions;
  313.     property BeforeDispatch;
  314.     property AfterDispatch;
  315.   end;
  316.  
  317. { TWebModule }
  318.  
  319.   TWebModule = class(TCustomWebDispatcher)
  320.   public
  321.     constructor Create(AOwner: TComponent); override;
  322.   published
  323.     property Actions;
  324.     property BeforeDispatch;
  325.     property AfterDispatch;
  326.   end;
  327.  
  328.   TWebApplication = class(TComponent)
  329.   protected
  330.     function ActivateWebModule: TDataModule;
  331.     procedure DeactivateWebModule(DataModule: TDataModule);
  332.     procedure DoHandleException(E: Exception); dynamic;
  333.     function HandleRequest(Request: TWebRequest; Response: TWebResponse): Boolean;
  334.   public
  335.     constructor Create(AOwner: TComponent); override;
  336.     destructor Destroy; override;
  337.     // The following is uses the current behaviour of the IDE module manager
  338.     procedure CreateForm(InstanceClass: TComponentClass; var Reference); virtual;
  339.     procedure Initialize; virtual;
  340.     procedure Run; virtual;
  341.     property ActiveCount: Integer;
  342.     property CacheConnections: Boolean;
  343.     property InactiveCount: Integer;
  344.     property MaxConnections: Integer;
  345.     property Title: string;
  346.   end;
  347.  
  348. function DosPathToUnixPath(const Path: string): string;
  349. function HTTPDecode(const AStr: String): string;
  350. function HTTPEncode(const AStr: String): string;
  351. function ParseDate(const DateStr: string): TDateTime;
  352. procedure ExtractHTTPFields(Separators, WhiteSpace: TCharSet; Content: PChar;
  353.   Strings: TStrings);
  354. function StatusString(StatusCode: Integer): string;
  355. function UnixPathToDosPath(const Path: string): string;
  356.  
  357. var
  358.   Application: TWebApplication = nil;
  359.  
  360. implementation
  361.